perm filename BUDGET.LSP[PRO,HE] blob
sn#650947 filedate 1982-04-02 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00073 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 Load files for compilation.
C00007 00003 <=my[my1,my2]
C00008 00004 >my[my1,my2]
C00009 00005 add-budget[x,y]
C00012 00006 add-idamtlist-idamt[l,i]
C00013 00007 add-idamtlist-idamtlist[l1,l2]
C00014 00008 benefits[my]
C00015 00009 bs[] is for BIS debugging.
C00016 00010 budget[] is the top-level command reader.
C00018 00011 budget-for-my[my]
C00025 00012 budget-for-period[p]
C00027 00013 cents[x]
C00028 00014 cmd-budget[]
C00030 00015 cmd-clear[]
C00031 00016 cmd-exe[]
C00032 00017 cmd-help[]
C00034 00018 cmd-monthly[]
C00035 00019 cmd-overhead[]
C00036 00020 cmd-project[]
C00038 00021 cmd-read[]
C00040 00022 cmd-status[]
C00045 00023 dollars[x]
C00046 00024 fixnump[x]
C00047 00025 get-monthly-salary[id,my]
C00049 00026 get-monthly-salary-directly[id,my]
C00050 00027 grant-status[pr]
C00052 00028 grant-status-lessp[gs1,gs2]
C00053 00029 in-period[myp]
C00054 00030 input-cap[transaction]
C00056 00031 input-emp[transaction]
C00059 00032 input-misc[transaction]
C00062 00033 input-period[transaction]
C00064 00034 input-salary[transaction]
C00066 00035 input-title[transaction]
C00068 00036 itemise[id-amt-list]
C00069 00037 n-chars[id,n] converts ID into a string of length N.
C00070 00038 n-chars-rjust[id,n]
C00071 00039 named-period[p]
C00072 00040 new-output-page[]
C00073 00041 next-my[my]
C00074 00042 overhead[my]
C00075 00043 process[transaction]
C00077 00044 project[gs,my]
C00091 00045 project-all-grants[]
C00093 00046 project-for-period[p]
C00095 00047 read-cmd[]
C00096 00048 read-file-name[default-ext]
C00098 00049 spaces[n]
C00099 00050 throw-bad-grant[grant,transaction,tag]
C00100 00051 throw-bad-id[id,transaction,tag]
C00101 00052 throw-bad-monthly-rate[rate,transaction,tag]
C00103 00053 throw-bad-my[my,transaction,tag]
C00104 00054 throw-bad-percent[percent,transaction,tag]
C00105 00055 throw-bad-period[p,transaction,tag]
C00107 00056 tuition-remission-rate[my]
C00108 00057 valid-id[id]
C00109 00058 valid-my[my]
C00110 00059 valid-period[p]
C00111 00060 write-budget[b]
C00122 00061 write-dollars-[x]
C00123 00062 write-entrys[type,period]
C00126 00063 write-grant-status[gs]
C00129 00064 write-grant-summarys[]
C00131 00065 write-money[x]
C00133 00066 write-money-[x]
C00134 00067 write-my[my]
C00135 00068 write-page-mark[]
C00136 00069 write-percent-[percent]
C00137 00070 write-person-historys[phs,p]
C00142 00071 write-projection[pr]
C00148 00072 write-source-files[]
C00149 00073 write-time-stamp[]
C00150 ENDMK
C⊗;
;Load files for compilation.
(EVAL-WHEN (COMPILE)
(OR (BOUNDP '|.loaded.|) (FASLOAD LOADER FAS DSK (SYS ROD)))
(LOADUP (RECORD FAS DSK (SYS ROD))
(USEDEC LSP DSK (SYS ROD))
(DECLAR LSP DSK (SYS ROD))
(GRAPHS LSP DSK (SYS ROD))
(BISUTL LSP DSK (SYS BIS))
(BUDGET REC DSK (sys BIS) L)))
;<=my[my1,my2]
;returns T if and only if the date MY1 is at or before the date MY2.
(DEFUN <=MY (MY1 MY2)
(LET M1 ← ∂MY:MONTH[MY1]
Y1 ← ∂MY:YEAR[MY1]
M2 ← ∂MY:MONTH[MY2]
Y2 ← ∂MY:YEAR[MY2]
DO
(OR (< Y1 Y2)
(AND (= Y1 Y2) (OR (= M1 M2) (< M1 M2)))))
) ;end-defun
;>my[my1,my2]
;returns T if and only if the date MY1 is after the date MY2.
(DEFUN >MY (MY1 MY2)
(LET M1 ← ∂MY:MONTH[MY1]
Y1 ← ∂MY:YEAR[MY1]
M2 ← ∂MY:MONTH[MY2]
Y2 ← ∂MY:YEAR[MY2]
DO
(OR (> Y1 Y2)
(AND (= Y1 Y2) (> M1 M2))))
) ;end-defun
;add-budget[x,y]
;returns the result of adding together the BUDGETs X and Y.
(DEFUN ADD-BUDGET (X Y)
(LET Z ← X
DO
∂BUDGET:SEN[Z] ← (ADD-IDAMTLIST-IDAMTLIST ∂BUDGET:SEN[Z] ∂BUDGET:SEN[Y])
∂BUDGET:SRA[Z] ← (ADD-IDAMTLIST-IDAMTLIST ∂BUDGET:SRA[Z] ∂BUDGET:SRA[Y])
∂BUDGET:TSRA[Z] ← (+$ ∂BUDGET:TSRA[Z] ∂BUDGET:TSRA[Y])
∂BUDGET:SUP[Z] ← (ADD-IDAMTLIST-IDAMTLIST ∂BUDGET:SUP[Z] ∂BUDGET:SUP[Y])
∂BUDGET:TSW[Z] ← (+$ ∂BUDGET:TSW[Z] ∂BUDGET:TSW[Y])
∂BUDGET:BEN[Z] ← (+$ ∂BUDGET:BEN[Z] ∂BUDGET:BEN[Y])
∂BUDGET:TSWB[Z] ← (+$ ∂BUDGET:TSWB[Z] ∂BUDGET:TSWB[Y])
∂BUDGET:CAP[Z] ← (ADD-IDAMTLIST-IDAMTLIST ∂BUDGET:CAP[Z] ∂BUDGET:CAP[Y])
∂BUDGET:TCAP[Z] ← (+$ ∂BUDGET:TCAP[Z] ∂BUDGET:TCAP[Y])
∂BUDGET:EXP[Z] ← (+$ ∂BUDGET:EXP[Z] ∂BUDGET:EXP[Y])
∂BUDGET:FOR[Z] ← (+$ ∂BUDGET:FOR[Z] ∂BUDGET:FOR[Y])
∂BUDGET:DOM[Z] ← (+$ ∂BUDGET:DOM[Z] ∂BUDGET:DOM[Y])
∂BUDGET:PUB[Z] ← (+$ ∂BUDGET:PUB[Z] ∂BUDGET:PUB[Y])
∂BUDGET:COMM[Z] ← (+$ ∂BUDGET:COMM[Z] ∂BUDGET:COMM[Y])
∂BUDGET:COMP[Z] ← (+$ ∂BUDGET:COMP[Z] ∂BUDGET:COMP[Y])
∂BUDGET:MER[Z] ← (+$ ∂BUDGET:MER[Z] ∂BUDGET:MER[Y])
∂BUDGET:TCBO[Z] ← (+$ ∂BUDGET:TCBO[Z] ∂BUDGET:TCBO[Y])
∂BUDGET:IND[Z] ← (+$ ∂BUDGET:IND[Z] ∂BUDGET:IND[Y])
∂BUDGET:REM[Z] ← (+$ ∂BUDGET:REM[Z] ∂BUDGET:REM[Y])
∂BUDGET:TC[Z] ← (+$ ∂BUDGET:TC[Z] ∂BUDGET:TC[Y])
Z)
) ;end-defun
;add-idamtlist-idamt[l,i]
;adds an ID-AMT into a list of ID-AMTs.
;For example:
; < <a,1>,<b,1> > + <c,1> → < <a,1>,<b,1>,<c,1> >
; < <a,1>,<b,1> > + <a,1> → < <a,2>,<b,1> >
; < <a,1>,<b,1> > + <b,1> → < <a,1>,<b,2> >
(DEFUN ADD-IDAMTLIST-IDAMT (L I)
(COND
((NULL L) (LIST I))
((EQ ∂ID-AMT:ID[(CAR L)] ∂ID-AMT:ID[I])
(CONS (CREATE ID-AMT
ID ∂ID-AMT:ID[I]
AMT (+$ ∂ID-AMT:AMT[(CAR L)] ∂ID-AMT:AMT[I]))
(CDR L)))
(T (CONS (CAR L) (ADD-IDAMTLIST-IDAMT (CDR L) I))))
) ;end-defun
;add-idamtlist-idamtlist[l1,l2]
;adds together the two lists of ID-AMTs.
;Example:
; < <a,1>,<b,1> > + < <c,1>,<a,1> > → < <a,2>,<b,1>,<c,1> >
(DEFUN ADD-IDAMTLIST-IDAMTLIST (L1 L2)
(COND
((NULL L2) L1)
(T (ADD-IDAMTLIST-IDAMTLIST (ADD-IDAMTLIST-IDAMT L1 (CAR L2))
(CDR L2))))
) ;end-defun
;benefits[my]
;returns the benefit rate for the date MY.
;These rates come from Betty Scotty, dated 23 September 1981.
(DEFUN BENEFITS (MY)
(DECLARE (SPECIAL $OK))
(COND
((IN-PERIOD MY '((9 79) (8 80))) 0.192)
((IN-PERIOD MY '((9 80) (8 81))) 0.192)
((IN-PERIOD MY '((9 81) (8 82))) 0.193)
((IN-PERIOD MY '((9 82) (8 83))) 0.204)
((IN-PERIOD MY '((9 83) (8 84))) 0.221)
((IN-PERIOD MY '((9 84) (8 85))) 0.224)
((IN-PERIOD MY '((9 85) (8 86))) 0.231)
(T (WRITELN '|ERROR: Benefits rate unavailable for month = | MY)
(SETQ $OK NIL)
0.0))
) ;end-defun
;bs[] is for BIS debugging.
(DEFUN BS ()
(UNDRIBBLE)
(QUIT)
) ;end-defun
;budget[] is the top-level command reader.
(DEFUN BUDGET ()
(SETQ $MISC NIL)
(SETQ $EMP NIL)
(SETQ $CAP NIL)
(SETQ $PERIODS NIL)
(SETQ $SAL NIL)
(SETQ $EXE-FILES NIL)
(WRITELN '|Welcome to BUDGET|)
(TERPRI)
(WRITE '|How may I serve you, Master? |)
(DO
((CMD (READ-CMD) (READ-CMD)))
((MEMQ CMD '(EXIT HALT Q QUIT STOP))
(WRITELN '|It has been our pleasure...|)
'*)
(IF (AND (ATOM CMD) (NOT (NUMBERP CMD)))
THEN
(CASEQ CMD
(BS (BS))
(BUDGET (CMD-BUDGET))
(CLEAR (CMD-CLEAR))
(E (EVAL (READ-CMD)))
(EXE (CMD-EXE))
(HELP (CMD-HELP))
(INDIRECT (CMD-OVERHEAD))
(MONTHLY (CMD-MONTHLY))
(OVERHEAD (CMD-OVERHEAD))
(PROJECT (CMD-PROJECT))
(READ (CMD-READ))
(STATUS (CMD-STATUS))
(T (WRITELN '|Sorry, but `| CMD '|' isn't a valid command.|)))
ELSE
(WRITELN '|Sorry, but `| CMD '|' isn't a valid command.|))
(WRITE '|How may I serve you, Master? |))
) ;end-defun
;budget-for-my[my]
;computes the budget for a specified month.
;It returns a BUDGET record for that single month PERIOD.
(DEFUN BUDGET-FOR-MY (MY)
(DECLARE (SPECIAL $OK))
;Initialise data fields of the output BUDGET record.
(LET PERIOD ← (CREATE PERIOD START MY STOP MY)
SEN ← NIL SRA ← NIL TSRA ← 0.0 SUP ← NIL
TSW ← 0.0 BEN ← 0.0 TSWB ← 0.0
CAP ← NIL TCAP ← 0.0
EXP ← 0.0 FOR ← 0.0 DOM ← 0.0 PUB ← 0.0 COMM ← 0.0 COMP ← 0.0
MER ← 0.0 TCBO ← 0.0 IND ← 0.0 REM ← 0.0 TC ← 0.0
SEN+SUP ← 0.0 ;omits students from benefits computation
DO
;Loop thru the employment records.
(FOR E ε $EMP DO
(IF (IN-PERIOD MY ∂EMP:PERIOD[E])
THEN
(LET ID ← ∂EMP:ID[E]
PERCENT ← ∂EMP:PERCENT[E]
CLASS ← ∂EMP:CLASS[E]
THEN
SALARY ← (GET-MONTHLY-SALARY ID MY)
THEN
X ← (*$ SALARY (//$ PERCENT 100.0))
DO
(CASEQ CLASS
(SEN (ADD-AT-END SEN (CREATE ID-AMT ID ID AMT X)))
(SRA (ADD-AT-END SRA (CREATE ID-AMT ID ID AMT X)))
(SUP (ADD-AT-END SUP (CREATE ID-AMT ID ID AMT X)))
(T (WRITELN '|* SYSTEM ERROR *|)
(WRITELN '|Illegal CLASS `| CLASS '|' returned by GET-PERSONNEL-CLASS|)
(WRITELN '| for ID = `| ID '|'|)
(SETQ $OK NIL))))))
;Compute totals for salaries and wages.
(FOR ITEM ε SEN DO
(INCREMENT-BY TSW ∂ID-AMT:AMT[ITEM])
(INCREMENT-BY SEN+SUP ∂ID-AMT:AMT[ITEM]))
(FOR ITEM ε SRA DO
(INCREMENT-BY TSRA ∂ID-AMT:AMT[ITEM])
(INCREMENT-BY TSW ∂ID-AMT:AMT[ITEM]))
(FOR ITEM ε SUP DO
(INCREMENT-BY TSW ∂ID-AMT:AMT[ITEM])
(INCREMENT-BY SEN+SUP ∂ID-AMT:AMT[ITEM]))
;Compute BEN and TSWB.
(LET BENEFIT-RATE ← (BENEFITS MY)
DO
(SETQ BEN (IF (<=MY MY '(12 99))
THEN
;Pay benefits for students before 09/81.
(*$ BENEFIT-RATE TSW)
ELSE
;No benefits paid for students from 09/81 onwards.
(*$ BENEFIT-RATE SEN+SUP))))
;Total salaries, wages, and benefits.
(SETQ TSWB (+$ TSW BEN))
;Capital equipment.
(FOR C ε $CAP DO
(IF (EQUAL MY ∂CAP:MY[C])
THEN
(LET ID ← ∂CAP:ID[C]
AMT ← ∂CAP:AMT[C]
DO
(INCREMENT-BY TCAP AMT)
(ADD-AT-END CAP (CREATE ID-AMT ID ID AMT AMT)))))
;Compute the other expenses.
(FOR E ε $MISC DO
(IF (IN-PERIOD MY ∂MISC:PERIOD[E])
THEN
(LET TYPE ← ∂MISC:TYPE[E]
MONTHLY ← ∂MISC:MONTHLY[E]
DO
(CASEQ TYPE
(EXP (INCREMENT-BY EXP MONTHLY))
(DOM (INCREMENT-BY DOM MONTHLY))
(FOR (INCREMENT-BY FOR MONTHLY))
(PUB (INCREMENT-BY PUB MONTHLY))
(COMM (INCREMENT-BY COMM MONTHLY))
(COMP (INCREMENT-BY COMP MONTHLY))
(MER (INCREMENT-BY MER MONTHLY))
(T (WRITELN '|* SYSTEM ERROR *|)
(WRITELN '|The following MISC record has illegal TYPE.|)
(WRITELN '| TYPE: | TYPE)
(WRITELN '| PERIOD: | PERIOD)
(WRITELN '| MONTHLY: | MONTHLY)
(SETQ $OK NIL))))))
;Total costs before overhead.
(SETQ TCBO (+$ TSWB TCAP EXP FOR DOM PUB COMM COMP MER))
;Compute overhead.
(LET OVERHEAD-RATE ← (OVERHEAD MY)
DO
(SETQ IND (*$ OVERHEAD-RATE
(+$ TSWB EXP FOR DOM PUB COMM COMP MER))))
;Compute tuition remission for students, if 09/81 or after.
(IF (>MY MY '(12 99))
THEN
(SETQ REM (*$ TSRA (TUITION-REMISSION-RATE MY))))
;Compute total of all costs this month.
(SETQ TC (+$ TCBO IND REM))
;Create and return the budget.
(CREATE BUDGET
PERIOD PERIOD
SEN SEN SRA SRA TSRA TSRA SUP SUP TSW TSW BEN BEN TSWB TSWB
CAP CAP TCAP TCAP EXP EXP FOR FOR DOM DOM PUB PUB
COMM COMM COMP COMP MER MER TCBO TCBO IND IND REM REM TC TC))
) ;end-defun
;budget-for-period[p]
;computes a BUDGET record for a specified PERIOD P.
(DEFUN BUDGET-FOR-PERIOD (P)
(LET START ← ∂PERIOD:START[P]
STOP ← ∂PERIOD:STOP[P]
;Initialise slots for the result.
TOTAL-BUDGET ← (CREATE BUDGET PERIOD P)
DO
(DO
((MY START (NEXT-MY MY)))
((>MY MY STOP) TOTAL-BUDGET)
(LET MONTH-BUDGET ← (BUDGET-FOR-MY MY)
DO
;Write out the monthly budget if the user wants it.
(IF $PRINT-BUDGET-MONTHLY
THEN
(WRITE-BUDGET MONTH-BUDGET))
;Add the new budget into the old one.
(SETQ TOTAL-BUDGET (ADD-BUDGET TOTAL-BUDGET MONTH-BUDGET)))))
) ;end-defun
;cents[x]
;returns a list of the two characters which follow the decimal point
;in the character representation of the POSITIVE FLOATNUM X.
(DEFUN CENTS (X)
(LET CHARS ← (EXPLODE X)
THEN
;Toss away characters up to and including the dot.
CHARS ← (DO ((C CHARS (CDR C)))
((EQ '|.| (CAR C)) (CDR C)))
THEN
;Get the two characters after the dot.
TENS ← (CAR CHARS) ;First one is always there.
ONES ← (IF (NULL (CDR CHARS)) THEN '/0 ELSE (CADR CHARS))
DO
;Give the user what he wants.
(LIST TENS ONES))
) ;end-defun
;cmd-budget[]
;constructs a budget for a given month-year or period.
(DEFUN CMD-BUDGET ()
(DECLARE (SPECIAL $OK P FILE))
(*CATCH 'ABORT-CMD
;Verify that data has been read in.
(IF (NOT $DATA-READ)
THEN
(WRITELN '|Sorry, but no data has been read in yet.|)
(*THROW 'ABORT-CMD NIL))
;Determine what PERIOD we're dealing with.
(WRITE '|For what period or month? |)
(LET Q ← (READ-CMD)
THEN
P ← (COND
((NAMED-PERIOD Q) (EVAL Q))
((VALID-PERIOD Q) Q)
((VALID-MY Q)
(CREATE PERIOD START Q STOP Q))
(T (WRITELN '|Sorry, but that's not a valid period or month.|)
(*THROW 'ABORT-CMD NIL)))
DO
;Establish the output file.
(WRITE '|File name? |)
(LET FILE ← (READ-FILE-NAME 'OUT)
$OK ← T
DO
(WRITE '|Writing OUT file: |)
(WRITE-A-FILE-SPEC FILE)(TERPRI)
(WRITE-A-FILE (CAR FILE) (CADR FILE) (CDDR FILE)
(SETQ $OUTPUT-FILE-EMPTY T)
(LET B ← (BUDGET-FOR-PERIOD P)
DO
(WRITE-BUDGET B)))
(IF $OK
THEN
(WRITELN '|Successful!|)
ELSE
(WRITELN '|!!! ERRORS !!! Check output file!|)))))
) ;end-defun
;cmd-clear[]
;clears all data and resets all flags.
(DEFUN CMD-CLEAR ()
(SETQ $GRANT-NAMES NIL)
(SETQ $GRANT-STATUSES NIL)
(SETQ $MISC NIL)
(SETQ $EMP NIL)
(SETQ $CAP NIL)
(SETQ $PERIODS NIL)
(SETQ $SAL NIL)
(SETQ $DATA-READ NIL)
(SETQ $STATUS-READ NIL)
(SETQ $TITLE 'UNTITLED)
(SETQ $SOURCE-FILES NIL)
(WRITELN '|--- all data CLEARed ---|)
) ;end-defun
;cmd-exe[]
;adds another file to the stack of EXE files.
(DEFUN CMD-EXE ()
(WRITE '|Command file? |)
(LET FILE ← (READ-FILE-NAME 'EXE)
THEN
INFILE ← (EOPEN FILE '(IN ASCII))
DO
(WRITE '|Reading EXE file: |)
(WRITE-A-FILE-SPEC FILE)(TERPRI)
(ADD-AT-END $SOURCE-FILES (CONS 'EXE FILE))
(SETQ $EXE-FILES (CONS INFILE $EXE-FILES)))
) ;end-defun
;cmd-help[]
;gives some help to the luser.
(DEFUN CMD-HELP ()
(TERPRI)
(WRITELN '|BUDGET produces an output budget file|)
(WRITELN '|EXE take commands from a file|)
(WRITELN '|HELP displays this message|)
(WRITELN '|INDIRECT controls the charging of overhead on a projection|)
(WRITELN '|MONTHLY controls the output of monthly budgets|)
(WRITELN '|OVERHEAD controls the charging of overhead on a projection|)
(WRITELN '|PROJECT produces a grant projection for a month|)
(WRITELN '|QUIT exit this program to top-level LISP|)
(WRITELN '|READ reads a new set of data declarations|)
(WRITELN '|STATUS prompts to fill current grant status|)
(TERPRI)
) ;end-defun
;cmd-monthly[]
;sets and resets the $PRINT-MONTHLY-BUDGETS flag.
(DEFUN CMD-MONTHLY ()
(WRITE '|On or off? |)
(LET ANSWER ← (READ-CMD)
DO
(COND
((EQ 'ON ANSWER) (SETQ $PRINT-MONTHLY-BUDGETS T))
((EQ 'OFF ANSWER) (SETQ $PRINT-MONTHLY-BUDGETS NIL))
(T (WRITELN '|Sorry, but | ANSWER '| is not a valid response.|))))
) ;end-defun
;cmd-overhead[]
;sets and resets the $OVERHEAD flag.
;Overhead (indirect costs) are charged iff this flag is T.
(DEFUN CMD-OVERHEAD ()
(WRITE '|On or off? |)
(LET ANSWER ← (READ-CMD)
DO
(COND
((EQ 'ON ANSWER) (SETQ $OVERHEAD T))
((EQ 'OFF ANSWER) (SETQ $OVERHEAD NIL))
(T (WRITELN '|Sorry, but | ANSWER '| is not a valid response.|))))
) ;end-defun
;cmd-project[]
(DEFUN CMD-PROJECT ()
(DECLARE (SPECIAL $OK PERIOD FILE))
(*CATCH 'ABORT-CMD-PROJECT
(LET PERIOD ← NIL
FILE ← NIL
$OK ← T
DO
;Determine what PERIOD we're dealing with.
(WRITE '|For what period or month? |)
(LET Q ← (READ-CMD)
DO
(SETQ PERIOD
(COND
((NAMED-PERIOD Q) (EVAL Q))
((VALID-PERIOD Q) Q)
((VALID-MY Q)
(CREATE PERIOD START Q STOP Q))
(T (WRITELN '|Sorry, but that's not a valid period or month.|)
(*THROW 'ABORT-CMD-PROJECT NIL)))))
;Establish the output file.
(WRITE '|File name? |)
(SETQ FILE (READ-FILE-NAME 'OUT))
(WRITE '|Writing OUT file: |)
(WRITE-A-FILE-SPEC FILE)(TERPRI)
(WRITE-A-FILE (CAR FILE) (CADR FILE) (CDDR FILE)
(SETQ $OUTPUT-FILE-EMPTY T)
(IF $PRINT-SOURCE-FILES
THEN
(NEW-OUTPUT-PAGE)
(WRITE-SOURCE-FILES))
(PROJECT-ALL-GRANTS))
(BEEP)
(IF $OK
THEN
(WRITELN '|Successful!|)
ELSE
(WRITELN '|!!! ERRORS !!! Check output file!|))))
) ;end-defun
;cmd-read[]
;reads a data file and puts it into internal format.
(DEFUN CMD-READ ()
(WRITE '|Input data file? |)
(LET FILE ← (READ-FILE-NAME 'IN)
THEN
INFILE ← (EOPEN FILE '(IN ASCII))
DO
(WRITE '|Reading IN file: |)
(WRITE-A-FILE-SPEC FILE)(TERPRI)
(ADD-AT-END $SOURCE-FILES (CONS 'READ FILE))
(*CATCH 'CMD-READ-LOOP
(DO NIL (NIL) ;forever
(LET TRANSACTION ← (READ INFILE 'EOF)
DO
(IF (EQUAL 'EOF TRANSACTION)
THEN (CLOSE INFILE) (*THROW 'CMD-READ-LOOP NIL)
ELSE (PROCESS TRANSACTION))))))
(SETQ $DATA-READ T)
) ;end-defun
;cmd-status[]
(SETQ $GS-ECHO NIL)
(DEFUN CMD-STATUS NIL
(*CATCH 'BAD-STATUS-COMMAND
(LET GRANT-NAME ← NIL
OVERHEAD ← T
MY ← NIL
TSW-TD ← NIL
TSW-BUD ← NIL
BEN-TD ← NIL
BEN-BUD ← NIL
CAP-TD ← NIL
CAP-BUD ← NIL
TRA-TD ← NIL
TRA-BUD ← NIL
EXP-TD ← NIL
EXP-BUD ← NIL
IND-TD ← NIL
IND-BUD ← NIL
DO
(GS-WRITE '|What is the name of this grant? |)
(SETQ GRANT-NAME (READ-CMD))
(COND
((NOT (ATOM GRANT-NAME))
(WRITELN '|Sorry, but `|
GRANT-NAME
'|' is not a valid name for a grant.|)
(BAD-STATUS))
((MEMQ GRANT-NAME $GRANT-NAMES)
(WRITELN '|Sorry, but `|
GRANT-NAME
'|' is a repetition of a previous grant name.|)
(BAD-STATUS)))
(GS-WRITE '|Is overhead charged on this grant? (T,NIL) |)
(SETQ OVERHEAD (READ-CMD))
(IF (NOT (MEMQ OVERHEAD '(T NIL)))
THEN
(WRITELN '|Sorry, but `| OVERHEAD '|' is not a valid OVERHEAD.|)
(BAD-STATUS))
(GS-WRITE '|At the end of what (month year) is this status valid? |)
(SETQ MY (READ-CMD))
(IF (NOT (VALID-MY MY))
THEN
(WRITELN '|Sorry, but `| MY '|' is not a valid MY.|)
(BAD-STATUS))
(READ-STATUS-ENTRY '|Salaries and Wages, to date? | TSW-TD)
(READ-STATUS-ENTRY '|Salaries and Wages, budgeted? | TSW-BUD)
(READ-STATUS-ENTRY '|Staff Benefits, to date? | BEN-TD)
(READ-STATUS-ENTRY '|Staff Benefits, budgeted? | BEN-BUD)
(READ-STATUS-ENTRY '|Capital Expenditures, to date? | CAP-TD)
(READ-STATUS-ENTRY '|Capital Expenditures, budgeted? | CAP-BUD)
(READ-STATUS-ENTRY '|Travel, to date? | TRA-TD)
(READ-STATUS-ENTRY '|Travel, budgeted? | TRA-BUD)
(READ-STATUS-ENTRY '|Other Expenses, to date? | EXP-TD)
(READ-STATUS-ENTRY '|Other Expenses, budgeted? | EXP-BUD)
(READ-STATUS-ENTRY '|Indirect Costs, to date? | IND-TD)
(READ-STATUS-ENTRY '|Indirect Costs, budgeted? | IND-BUD)
(ADD-AT-END $GRANT-NAMES GRANT-NAME)
(ADD-AT-END $GRANT-STATUSES
(CREATE GRANT-STATUS
GRANT-NAME GRANT-NAME
OVERHEAD OVERHEAD
MY MY
TSW-TD TSW-TD
TSW-BUD TSW-BUD
BEN-TD BEN-TD
BEN-BUD BEN-BUD
CAP-TD CAP-TD
CAP-BUD CAP-BUD
TRA-TD TRA-TD
TRA-BUD TRA-BUD
EXP-TD EXP-TD
EXP-BUD EXP-BUD
IND-TD IND-TD
IND-BUD IND-BUD))))
) ;end-defun
;dollars[x]
;returns a list of the characters to the left of the decimal point
;of the POSITIVE FLOATNUM X.
(DEFUN DOLLARS (X)
(LET CHARS ← (EXPLODE X)
RESULT ← NIL
DO
(DO
((C CHARS (CDR C)))
((EQ (CAR C) '|.|) (REVERSE RESULT))
(SETQ RESULT (CONS (CAR C) RESULT))))
) ;end-defun
;fixnump[x]
;returns T if and only if X is a floating-point number.
(DEFUN FIXNUMP (X)
(EQ 'FIXNUM (TYPEP X))
) ;end-defun
;get-monthly-salary[id,my]
;returns the salary of the person ID for the MONTH-YEAR MY.
;Here's how it's done.
;If we have a salary for MY for ID, then all's well.
;Otherwise, we try finding a salary for that month one year before.
;If we find one, then we inflate it by 10%.
;To prevent infinite loops,
;we never go further back than 5 years.
(DEFUN GET-MONTHLY-SALARY (ID MY)
(DECLARE (SPECIAL $OK))
(*CATCH 'GET-MONTHLY-SALARY
(DO
((YEARS-BACK 0 (1+ YEARS-BACK))
(INFLATION 1.0 (*$ 1.1 INFLATION)))
((> YEARS-BACK 4)
(SETQ $OK NIL)
(WRITE '|ERROR: Can't find or compute a salary for person | ID '| for month |)
(WRITE-MY MY)
(TERPRI)
0.0)
;Create an MY for the earlier year.
(LET EARLIER-MY ← (CREATE MY
MONTH ∂MY:MONTH[MY]
YEAR (- ∂MY:YEAR[MY] YEARS-BACK))
THEN
;Have we got a salary for this earlier MY?
EARLIER-SALARY ← (GET-MONTHLY-SALARY-DIRECTLY ID EARLIER-MY)
DO
(IF EARLIER-SALARY
THEN
(*THROW 'GET-MONTHLY-SALARY (*$ INFLATION EARLIER-SALARY))))))
) ;end-defun
;get-monthly-salary-directly[id,my]
;returns a salary if an appropriate SAL record exists,
;else returns NIL.
(DEFUN GET-MONTHLY-SALARY-DIRECTLY (ID MY)
(*CATCH 'GET-MONTHLY-SALARY-DIRECTLY
(FOR S ε $SAL DO
(IF (AND (EQ ID ∂SAL:ID[S])
(IN-PERIOD MY ∂SAL:PERIOD[S]))
THEN
(*THROW 'GET-MONTHLY-SALARY-DIRECTLY ∂SAL:MONTHLY[S]))))
) ;end-defun
;grant-status[pr]
;returns the GRANT-STATUS record deducible from the PROJECTION PR.
(DEFUN GRANT-STATUS (PR)
(LET OUT ← (CREATE GRANT-STATUS)
DO
∂GRANT-STATUS:MY[OUT] ← ∂PROJECTION:MY[PR]
∂GRANT-STATUS:TSW-TD[OUT] ← ∂PROJECTION:SW-TOT:TD[PR]
∂GRANT-STATUS:TSW-BUD[OUT] ← ∂PROJECTION:SW-TOT:BUD[PR]
∂GRANT-STATUS:BEN-TD[OUT] ← ∂PROJECTION:BEN-TOT:TD[PR]
∂GRANT-STATUS:BEN-BUD[OUT] ← ∂PROJECTION:BEN-TOT:BUD[PR]
∂GRANT-STATUS:CAP-TD[OUT] ← ∂PROJECTION:CAP-TOT:TD[PR]
∂GRANT-STATUS:CAP-BUD[OUT] ← ∂PROJECTION:CAP-TOT:BUD[PR]
∂GRANT-STATUS:TRA-TD[OUT] ← ∂PROJECTION:TRA-TOT:TD[PR]
∂GRANT-STATUS:TRA-BUD[OUT] ← ∂PROJECTION:TRA-TOT:BUD[PR]
∂GRANT-STATUS:EXP-TD[OUT] ← ∂PROJECTION:EXP-TOT:TD[PR]
∂GRANT-STATUS:EXP-BUD[OUT] ← ∂PROJECTION:EXP-TOT:BUD[PR]
∂GRANT-STATUS:IND-TD[OUT] ← ∂PROJECTION:IND:TD[PR]
∂GRANT-STATUS:IND-BUD[OUT] ← ∂PROJECTION:IND:BUD[PR]
OUT)
) ;end-defun
;grant-status-lessp[gs1,gs2]
(DEFUN GRANT-STATUS-LESSP (GS1 GS2)
(LET GN1 ← ∂GRANT-STATUS:GRANT-NAME[GS1]
GN2 ← ∂GRANT-STATUS:GRANT-NAME[GS2]
DO
(ALPHALESSP GN1 GN2))
) ;end-defun
;in-period[my;p]
;returns T if and only if the MONTH-YEAR MY is in the PERIOD P.
(DEFUN IN-PERIOD (MY P)
(LET START ← ∂PERIOD:START[P]
STOP ← ∂PERIOD:STOP[P]
DO
(AND (<=MY START MY)
(<=MY MY STOP)))
) ;end-defun
;input-cap[transaction]
;converts a CAP record from external to internal form.
;Such records represent capital expenditures.
;External:
; < CAP id grant my amt >
;Internal:
; < grant id my amt >
(DEFUN INPUT-CAP (TRANSACTION)
(*CATCH 'BAD-CAP
(IF (NOT (= 5 (LENGTH TRANSACTION)))
THEN
(WRITELN '|Sorry, but the following transaction has improper length:|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW 'BAD-CAP NIL))
(LET ID ← (NTH 1 TRANSACTION)
GRANT ← (NTH 2 TRANSACTION)
MY ← (NTH 3 TRANSACTION)
AMT ← (NTH 4 TRANSACTION)
DO
;Check GRANT.
(THROW-BAD-GRANT GRANT TRANSACTION 'BAD-CAP)
;Check ID.
(THROW-BAD-ID ID TRANSACTION 'BAD-CAP)
;Check MY.
(THROW-BAD-MY MY TRANSACTION 'BAD-CAP)
;Check AMT.
(IF (NUMBERP AMT)
THEN
(SETQ AMT (FLOAT AMT))
ELSE
(WRITELN '|Sorry, but `| AMT '|' is not a valid AMT|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW 'BAD-CAP NIL))
;Create an CAP record and add it at the end of $CAP.
(ADD-AT-END $CAP
(CREATE CAP GRANT GRANT ID ID MY MY AMT AMT))))
) ;end-defun
;input-emp[transaction]
;converts an EMPLOY record from external to internal form.
;Such records represent hiring people at percentages for periods.
;External:
; < EMPLOY id grant period percent class comment>
;Internal:
; < id grant period percent class comment>
;where CLASS ε { SEN,SRA,SUP }.
(DEFUN INPUT-EMP (TRANSACTION)
(*CATCH 'BAD-EMP
(IF (NOT (< 5 (LENGTH TRANSACTION)))
THEN
(WRITELN '|Sorry, but the following transaction has improper length:|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW 'BAD-EMP NIL))
(LET ID ← (NTH 1 TRANSACTION)
GRANT ← (NTH 2 TRANSACTION)
PERIOD ← (NTH 3 TRANSACTION)
PERCENT ← (NTH 4 TRANSACTION)
CLASS ← (NTH 5 TRANSACTION)
COMMENT ← (IF (= 7 (LENGTH TRANSACTION))
THEN (NTH 6 TRANSACTION)
ELSE NIL)
DO
;Check GRANT.
(THROW-BAD-GRANT GRANT TRANSACTION 'BAD-EMP)
;Check ID.
(THROW-BAD-ID ID TRANSACTION 'BAD-EMP)
;Check PERIOD.
(SETQ PERIOD (THROW-BAD-PERIOD PERIOD TRANSACTION 'BAD-EMP))
;Check PERCENT.
(SETQ PERCENT (THROW-BAD-PERCENT PERCENT TRANSACTION 'BAD-EMP))
;Check CLASS.
(IF (OR (NOT (ATOM CLASS))
(NUMBERP CLASS)
(NOT (MEMQ CLASS '(SEN SRA SUP))))
THEN
(WRITELN '|Sorry, but `| CLASS '|' is not a valid personnel class.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW 'BAD-EMP NIL))
;Create an EMP record and add it at the end of $EMP.
(ADD-AT-END $EMP
(CREATE EMP
GRANT GRANT
ID ID PERIOD PERIOD
PERCENT PERCENT CLASS CLASS
COMMENT COMMENT))))
) ;end-defun
;input-misc[transaction]
;converts a MISC record from external to internal form.
;Such records describe miscellaneous expenditures.
;External:
; < EXP grant rate period [id] > for expendibles
; < DOM grant rate period [id] > for domestic travel
; < FOR grant rate period [id] > for foreign travel
; < PUB grant rate period [id] > for publication
; < COMM grant rate period [id] > for communications, like telephone
; < COMP grant rate period [id] > for computer costs
; < MER grant rate period [id] > for minor equipment and repair
;ID defaults to UNSPECIFIED.
;Internal:
; < grant type period monthly id >
;where TYPE ε { EXP,DOM,FOR,PUB,COMM,COMP,MER }.
(DEFUN INPUT-MISC (TRANSACTION)
(*CATCH 'BAD-MISC
(IF (NOT (< 3 (LENGTH TRANSACTION)))
THEN
(WRITELN '|Sorry, but the following transaction has improper length:|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW 'BAD-MISC NIL))
(LET TYPE ← (NTH 0 TRANSACTION)
GRANT ← (NTH 1 TRANSACTION)
RATE ← (NTH 2 TRANSACTION)
PERIOD ← (NTH 3 TRANSACTION)
ID ← (IF (> (LENGTH TRANSACTION) 4)
THEN (NTH 4 TRANSACTION)
ELSE 'UNSPECIFIED)
DO
(IF (OR (NOT (ATOM TYPE))
(NUMBERP TYPE)
(NOT (MEMQ TYPE '(EXP DOM FOR PUB COMM COMP MER))))
THEN
(WRITELN '|Sorry, but `| TYPE '|' is not a valid expense TYPE.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW 'BAD-MISC NIL))
(SETQ RATE (THROW-BAD-MONTHLY-RATE RATE TRANSACTION 'BAD-MISC))
(SETQ PERIOD (THROW-BAD-PERIOD PERIOD TRANSACTION 'BAD-MISC))
(ADD-AT-END $MISC
(CREATE MISC
TYPE TYPE
GRANT GRANT
MONTHLY RATE
PERIOD PERIOD
ID ID))))
) ;end-defun
;input-period[transaction]
;converts a PERIOD from external to internal form.
;External:
; < PERIOD id period >
(DEFUN INPUT-PERIOD (TRANSACTION)
(*CATCH 'BAD-PERIOD
(LET NAME ← (CADR TRANSACTION)
DATES ← (CADDR TRANSACTION)
DO
(COND
((NOT (ATOM NAME))
(WRITELN '|Sorry, but `| NAME '|' is not an atom as required.|)
(WRITELN '|TRANSACTION = | TRANSACTION)
(*THROW 'BAD-PERIOD NIL))
((NUMBERP NAME)
(WRITELN '|Sorry, but `| NAME '|' is a number. That's not allowed.|)
(WRITELN '|TRANSACTION = | TRANSACTION)
(*THROW 'BAD-PERIOD NIL))
((MEMQ NAME $PERIODS)
(WRITELN '|Warning! `| NAME '|' is already defined as a PERIOD.|)
(WRITELN '|TRANSACTION = | TRANSACTION))
(T NIL))
;Check out that the DATES are ok.
(IF (NOT (VALID-PERIOD DATES))
THEN
(WRITELN '|Sorry, but `| DATES '|' is not a valid PERIOD.|)
(WRITELN '|TRANSACTION = | TRANSACTION)
(*THROW 'BAD-PERIOD NIL))
;Set NAME to have this value.
(SET NAME DATES)
;Remember it.
(SETQ $PERIODS (CONS NAME $PERIODS))))
) ;end-defun
;input-salary[transaction]
;converts a SALARY record from external to internal form.
;External:
; < SALARY id period rate >
;Internal:
; < id period monthly >
(DEFUN INPUT-SALARY (TRANSACTION)
(*CATCH 'BAD-SAL
(IF (NOT (= (LENGTH TRANSACTION) 4))
THEN
(WRITELN '|Sorry, but the following transaction has improper length:|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW 'BAD-SAL NIL))
(LET ID ← (CADR TRANSACTION)
PERIOD ← (CADDR TRANSACTION)
RATE ← (CADDDR TRANSACTION)
DO
;Check ID.
(THROW-BAD-ID ID TRANSACTION 'BAD-SAL)
;Check RATE.
(SETQ RATE (THROW-BAD-MONTHLY-RATE RATE TRANSACTION 'BAD-SAL))
;Check PERIOD.
(SETQ PERIOD (THROW-BAD-PERIOD PERIOD TRANSACTION 'BAD-SAL))
;Create the SALARY record and store it.
(ADD-AT-END $SAL
(CREATE SAL ID ID PERIOD PERIOD MONTHLY RATE))))
) ;end-defun
;input-title[transaction]
;reads a TITLE declaration of the form
; < TITLE id >
;which makes ID legal the only legal GRANT-NAME for transactions which follow.
(DEFUN INPUT-TITLE (TRANSACTION)
(*CATCH 'BAD-TITLE
(IF (NOT (= (LENGTH TRANSACTION) 2))
THEN
(WRITELN '|Sorry, but the following transaction has improper length:|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW 'BAD-TITLE NIL))
(LET ID ← (CADR TRANSACTION)
DO
;Check ID.
(IF (NOT (VALID-ID ID))
THEN
(WRITELN '|Sorry, but `| ID '|' is not a valid ID.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW 'BAD-TITLE NIL))
;Check that no other TITLE has been used.
(IF (MEMQ ID $GRANT-NAMES)
THEN
(WRITELN '|Sorry, but you are trying to give TITLE = |
ID)
(WRITELN '|when $GRANT-NAMES is non-NIL: |
$GRANT-NAMES)
(*THROW 'BAD-TITLE NIL))
(SETQ $GRANT-NAMES (LIST ID))))
) ;end-defun
;itemise[id-amt-list]
;itemises a list of ID-AMT pairs.
(DEFUN ITEMISE (ID-AMT-LIST)
(FOR ITEM ε ID-AMT-LIST DO
(SPACES 8)
(WRITE ∂ID-AMT:ID[ITEM])
(SPACES 5)
(WRITE-MONEY ∂ID-AMT:AMT[ITEM])
(TERPRI)
(TERPRI))
) ;end-defun
;n-chars[id,n] converts ID into a string of length N.
(DEFUN N-CHARS (ID N)
(LET L ← (EXPLODEC ID)
DO
(COND
((> (LENGTH L) N)
(N-CHARS (IMPLODE (REVERSE (CDR (REVERSE L)))) N))
((= (LENGTH L) N)
ID)
(T
(N-CHARS (IMPLODE (ADD-AT-END L '| |)) N))))
) ;end-defun
;n-chars-rjust[id,n]
;converts ID into a string of length N.
;If ID is shorter than N characters long, it gets padded on the left.
(DEFUN N-CHARS-RJUST (ID N)
(LET L ← (EXPLODEC ID)
DO
(COND
((> (LENGTH L) N)
(N-CHARS-RJUST (IMPLODE (REVERSE (CDR (REVERSE L)))) N))
((= (LENGTH L) N)
ID)
(T
(N-CHARS-RJUST (IMPLODE (CONS '| | L)) N))))
) ;end-defun
;named-period[p]
;returns T if and only if P is the name of a named PERIOD.
(DEFUN NAMED-PERIOD (P)
(AND
(ATOM P)
(NOT (NUMBERP P))
(MEMQ P $PERIODS))
) ;end-defun
;new-output-page[]
(DEFUN NEW-OUTPUT-PAGE ()
(IF $OUTPUT-FILE-EMPTY
THEN
(SETQ $OUTPUT-FILE-EMPTY NIL)
ELSE
(WRITE-PAGE-MARK))
) ;end-defun
;next-my[my]
;returns the month-year which follows the month-year MY.
(DEFUN NEXT-MY (MY)
(LET THIS-MONTH ← ∂MY:MONTH[MY]
THIS-YEAR ← ∂MY:YEAR[MY]
DO
(IF (< THIS-MONTH 12)
THEN
(CREATE MY
MONTH (1+ THIS-MONTH)
YEAR THIS-YEAR)
ELSE
(CREATE MY
MONTH 1
YEAR (1+ THIS-YEAR))))
) ;end-defun
;overhead[my]
;returns the overhead rate in effect for the month-year MY.
; Overhead rate changes Sept. 1, 1982 from 58% to 69%. -- DLO
(DEFUN OVERHEAD (MY)
(IF (>MY '(9 82) MY)
THEN 0.58
ELSE 0.69
)) ;end-defun
;process[transaction]
;converts an external data record into an internal one.
(DEFUN PROCESS (TRANSACTION)
(COND
((ATOM TRANSACTION)
(WRITELN '|The following transaction is an atom, and is not legal:|)
(WRITELN '|TRANSACTION=| TRANSACTION))
((< (LENGTH TRANSACTION) 2)
(WRITELN '|The following transaction has improper length:|)
(WRITELN '|TRANSACTION=| TRANSACTION))
(T (LET TYPE ← (CAR TRANSACTION)
DO
(CASEQ TYPE
(CAP (INPUT-CAP TRANSACTION))
(EMPLOY (INPUT-EMP TRANSACTION))
(PERIOD (INPUT-PERIOD TRANSACTION))
(SALARY (INPUT-SALARY TRANSACTION))
(TITLE (INPUT-TITLE TRANSACTION))
(EXP (INPUT-MISC TRANSACTION))
(DOM (INPUT-MISC TRANSACTION))
(FOR (INPUT-MISC TRANSACTION))
(PUB (INPUT-MISC TRANSACTION))
(COMM (INPUT-MISC TRANSACTION))
(COMP (INPUT-MISC TRANSACTION))
(MER (INPUT-MISC TRANSACTION))
(T (WRITELN '|Sorry, but the following transaction is unrecognised.|)
(WRITELN '|TRANSACTION=| TRANSACTION))))))
) ;end-defun
;project[gs,my]
;returns a PROJECTION for MY using GS as the current grant status.
(DEFUN PROJECT (GS MY)
(DECLARE (SPECIAL $OK))
(LET RESULT ← (CREATE PROJECTION MY MY)
DO
;Test interlock of GRANT-STATUS:MY and MY.
(LET GS-MY ← ∂GRANT-STATUS:MY[GS]
DO
(IF (NOT (EQUAL MY (NEXT-MY GS-MY)))
THEN
(WRITELN '|ERROR: Mismatch of GRANT-STATUS with month for projection.|)
(WRITE '| GRANT-STATUS shows |)
(WRITE-MY GS-MY)
(TERPRI)
(WRITE '| PROJECTion requested for |)
(WRITE-MY MY)
(TERPRI)
(SETQ $OK NIL)))
;Salary & Wages.
(LET SW-LINES ← NIL
SW-TM ← 0.0
SEN+SUP-TM ← 0.0 ;separate Senior and Support
SRA-TM ← 0.0 ; from SRAs
BEN-RATE ← (BENEFITS MY)
REM-RATE ← (TUITION-REMISSION-RATE MY)
DO
(FOR E ε $EMP DO
(IF (AND (EQ $TITLE ∂EMP:GRANT[E])
(IN-PERIOD MY ∂EMP:PERIOD[E]))
THEN
(LET ID ← ∂EMP:ID[E]
PERCENT ← ∂EMP:PERCENT[E]
CLASS ← ∂EMP:CLASS[E]
COMMENT ← ∂EMP:COMMENT[E]
THEN
MONTHLY ← (GET-MONTHLY-SALARY ID MY)
THEN
THIS-MONTH ← (*$ MONTHLY (//$ PERCENT 100.0))
DO
(ADD-AT-END SW-LINES
(CREATE SW-LINE
ID ID PERCENT PERCENT
MONTHLY MONTHLY
THIS-MONTH THIS-MONTH
COMMENT COMMENT))
(ADD-AT-END $PHS
(CREATE PERSON-HISTORY GRANT $TITLE
ID ID MY MY PERCENT PERCENT
SALARY MONTHLY AMT THIS-MONTH))
(CASEQ CLASS
(SRA (INCREMENT-BY SRA-TM THIS-MONTH))
(SEN (INCREMENT-BY SEN+SUP-TM THIS-MONTH))
(T (INCREMENT-BY SEN+SUP-TM THIS-MONTH))))))
;Fill the slot for SW-TOT.
(LET SW-TM ← (+$ SEN+SUP-TM SRA-TM)
SW-BUD ← ∂GRANT-STATUS:TSW-BUD[GS]
THEN
SW-TD ← (+$ ∂GRANT-STATUS:TSW-TD[GS] SW-TM)
THEN
TRIPLE ← (CREATE TRIPLE TM SW-TM TD SW-TD BUD SW-BUD)
DO
∂PROJECTION:SW-TOT[RESULT] ← TRIPLE)
;Fill the slot for SW.
∂PROJECTION:SW[RESULT] ← SW-LINES
;Compute and fill the slot for BEN-TOT and BEN-RATE.
(LET BEN-TM ← (*$ BEN-RATE
(IF (<=MY MY '(12 99))
THEN
;Pay benefits for students before 09/81.
(+$ SEN+SUP-TM SRA-TM)
ELSE
;No benefits paid for students from 09/81 onwards.
SEN+SUP-TM))
BEN-TD ← ∂GRANT-STATUS:BEN-TD[GS]
BEN-BUD ← ∂GRANT-STATUS:BEN-BUD[GS]
THEN
BEN-TD ← (+$ BEN-TD BEN-TM)
THEN
TRIPLE ← (CREATE TRIPLE TM BEN-TM TD BEN-TD BUD BEN-BUD)
DO
∂PROJECTION:BEN-RATE[RESULT] ← BEN-RATE
∂PROJECTION:BEN-TOT[RESULT] ← TRIPLE)
;Compute and fill the slot for REM-TOT and REM-RATE.
(LET REM-TM ← (*$ REM-RATE SRA-TM)
REM-TD ← ∂GRANT-STATUS:REM-TD[GS]
REM-BUD ← ∂GRANT-STATUS:REM-BUD[GS]
THEN
REM-TD ← (+$ REM-TD REM-TM)
THEN
TRIPLE ← (CREATE TRIPLE TM REM-TM TD REM-TD BUD REM-BUD)
DO
∂PROJECTION:REM-RATE[RESULT] ← REM-RATE
∂PROJECTION:REM-TOT[RESULT] ← TRIPLE))
;Capital equipment.
(LET CAP-TM ← 0.0
CAP-TD ← ∂GRANT-STATUS:CAP-TD[GS]
CAP-BUD ← ∂GRANT-STATUS:CAP-BUD[GS]
CAP ← NIL
DO
(FOR C ε $CAP DO
(IF (AND (EQ $TITLE ∂EMP:GRANT[C])
(EQUAL MY ∂CAP:MY[C]))
THEN
(LET ID ← ∂CAP:ID[C]
AMT ← ∂CAP:AMT[C]
THEN
ID-AMT ← (CREATE ID-AMT ID ID AMT AMT)
DO
(INCREMENT-BY CAP-TM AMT)
(ADD-AT-END CAP ID-AMT))))
;Fill the slot for CAP.
∂PROJECTION:CAP[RESULT] ← CAP
;Fill the slot for CAP-TOT.
∂PROJECTION:CAP-TOT[RESULT] ← (CREATE TRIPLE
TM CAP-TM
TD (+$ CAP-TD CAP-TM)
BUD CAP-BUD))
(ADD-AT-END $ENTRYS
(CREATE ENTRY
TYPE 'CAPITAL-EQUIPMENT
MY MY
GRANT $TITLE
AMT ∂PROJECTION:CAP-TOT:TM[RESULT]))
;Travel.
(LET TRA-TM ← 0.0
TRA-TD ← ∂GRANT-STATUS:TRA-TD[GS]
TRA-BUD ← ∂GRANT-STATUS:TRA-BUD[GS]
TRA ← NIL
DO
(FOR X ε $MISC DO
(IF (AND (MEMQ ∂MISC:TYPE[X] '(DOM FOR))
(EQ $TITLE ∂EMP:GRANT[X])
(IN-PERIOD MY ∂MISC:PERIOD[X]))
THEN
(LET ID ← ∂MISC:ID[X]
AMT ← ∂MISC:MONTHLY[X]
THEN
ID-AMT ← (CREATE ID-AMT ID ID AMT AMT)
DO
(INCREMENT-BY TRA-TM AMT)
(ADD-AT-END TRA ID-AMT))))
;Fill the slot for TRA.
∂PROJECTION:TRA[RESULT] ← TRA
;Fill the slot for TRA-TOT.
∂PROJECTION:TRA-TOT[RESULT] ← (CREATE TRIPLE
TM TRA-TM
TD (+$ TRA-TD TRA-TM)
BUD TRA-BUD))
(ADD-AT-END $ENTRYS
(CREATE ENTRY
TYPE 'TRAVEL
MY MY
GRANT $TITLE
AMT ∂PROJECTION:TRA-TOT:TM[RESULT]))
;Expendable Materials.
(LET EXP-TM ← 0.0
EXP-TD ← ∂GRANT-STATUS:EXP-TD[GS]
EXP-BUD ← ∂GRANT-STATUS:EXP-BUD[GS]
EXP ← NIL
DO
(FOR X ε $MISC DO
;Exclude travel, namely DOM and FOR.
(IF (AND (NOT (MEMQ ∂MISC:TYPE[X] '(DOM FOR)))
(EQ $TITLE ∂EMP:GRANT[X])
(IN-PERIOD MY ∂MISC:PERIOD[X]))
THEN
(LET ID ← ∂MISC:ID[X]
AMT ← ∂MISC:MONTHLY[X]
THEN
ID-AMT ← (CREATE ID-AMT ID ID AMT AMT)
DO
(INCREMENT-BY EXP-TM AMT)
(ADD-AT-END EXP ID-AMT))))
;Fill the slot for EXP.
∂PROJECTION:EXP[RESULT] ← EXP
;Fill the slot for EXP-TOT.
∂PROJECTION:EXP-TOT[RESULT] ← (CREATE TRIPLE
TM EXP-TM
TD (+$ EXP-TD EXP-TM)
BUD EXP-BUD))
;Indirect Costs and Total.
(LET TM ← 0.0
TD ← 0.0
BUD ← 0.0
;Watch for the $OVERHEAD flag.
IND-RATE ← (IF $OVERHEAD
THEN (OVERHEAD MY)
ELSE 0.0)
DO
;Salaries and Wages.
(INCREMENT-BY TM ∂PROJECTION:SW-TOT:TM[RESULT])
(INCREMENT-BY TD ∂PROJECTION:SW-TOT:TD[RESULT])
(INCREMENT-BY BUD ∂PROJECTION:SW-TOT:BUD[RESULT])
;Staff Benefits.
(INCREMENT-BY TM ∂PROJECTION:BEN-TOT:TM[RESULT])
(INCREMENT-BY TD ∂PROJECTION:BEN-TOT:TD[RESULT])
(INCREMENT-BY BUD ∂PROJECTION:BEN-TOT:BUD[RESULT])
;Travel.
(INCREMENT-BY TM ∂PROJECTION:TRA-TOT:TM[RESULT])
(INCREMENT-BY TD ∂PROJECTION:TRA-TOT:TD[RESULT])
(INCREMENT-BY BUD ∂PROJECTION:TRA-TOT:BUD[RESULT])
;Expendable Materials.
(INCREMENT-BY TM ∂PROJECTION:EXP-TOT:TM[RESULT])
(INCREMENT-BY TD ∂PROJECTION:EXP-TOT:TD[RESULT])
(INCREMENT-BY BUD ∂PROJECTION:EXP-TOT:BUD[RESULT])
;Compute and fill the slots for Indirect Costs.
∂PROJECTION:IND-RATE[RESULT] ← IND-RATE
(LET TM ← (*$ IND-RATE TM)
THEN
TD ← (+$ TM ∂GRANT-STATUS:IND-TD[GS])
DO
∂PROJECTION:IND[RESULT] ← (CREATE TRIPLE
TM TM TD TD
BUD ∂GRANT-STATUS:IND-BUD[GS]))
;Add Indirect Costs into the Total.
(INCREMENT-BY TM ∂PROJECTION:IND:TM[RESULT])
(INCREMENT-BY TD ∂PROJECTION:IND:TD[RESULT])
(INCREMENT-BY BUD ∂PROJECTION:IND:BUD[RESULT])
;Add Capital Expenditures into the Total.
(INCREMENT-BY TM ∂PROJECTION:CAP-TOT:TM[RESULT])
(INCREMENT-BY TD ∂PROJECTION:CAP-TOT:TD[RESULT])
(INCREMENT-BY BUD ∂PROJECTION:CAP-TOT:BUD[RESULT])
;Add Tuition Remission into the Total.
(INCREMENT-BY TM ∂PROJECTION:REM-TOT:TM[RESULT])
(INCREMENT-BY TD ∂PROJECTION:REM-TOT:TD[RESULT])
(INCREMENT-BY BUD ∂PROJECTION:REM-TOT:BUD[RESULT])
;Fill the slots for Total.
∂PROJECTION:TOT[RESULT] ← (CREATE TRIPLE
TM TM TD TD BUD BUD))
(LET GS ← (CREATE GRANT-SUMMARY
MY MY
SWB (+$ ∂PROJECTION:SW-TOT:TM[RESULT]
∂PROJECTION:REM-TOT:TM[RESULT]
∂PROJECTION:BEN-TOT:TM[RESULT])
CAP ∂PROJECTION:CAP-TOT:TM[RESULT]
TRA ∂PROJECTION:TRA-TOT:TM[RESULT]
EXP ∂PROJECTION:EXP-TOT:TM[RESULT]
IND ∂PROJECTION:IND:TM[RESULT]
TOT ∂PROJECTION:TOT:TM[RESULT]
REM (-$ ∂PROJECTION:TOT:BUD[RESULT]
∂PROJECTION:TOT:TD[RESULT]))
DO
(ADD-AT-END $GRANT-SUMMARYS GS))
(ADD-AT-END $ENTRYS
(CREATE ENTRY
TYPE 'BALANCE-REMAINING
MY MY
GRANT $TITLE
AMT (-$ ∂PROJECTION:TOT:BUD[RESULT]
∂PROJECTION:TOT:TD[RESULT])))
(ADD-AT-END $ENTRYS
(CREATE ENTRY
TYPE 'TOTAL-SPENT-THIS-MONTH
MY MY
GRANT $TITLE
AMT ∂PROJECTION:TOT:TM[RESULT]))
RESULT)
) ;end-defun
;project-all-grants[]
(DEFUN PROJECT-ALL-GRANTS ()
(DECLARE (SPECIAL PERIOD))
(SETQ $PHS NIL)
(SETQ $ENTRYS NIL)
;Sort $GRANT-STATUSES.
(SETQ $GRANT-STATUSES
(SORT $GRANT-STATUSES 'GRANT-STATUS-LESSP))
;Loop thru the grants.
(FOR GS ε $GRANT-STATUSES
DO
(SETQ $OVERHEAD ∂GRANT-STATUS:OVERHEAD[GS])
(SETQ $TITLE ∂GRANT-STATUS:GRANT-NAME[GS])
(SETQ $GRANT-STATUS GS)
(IF $PRINT-PROJECT-GS
THEN
(NEW-OUTPUT-PAGE)
(WRITE-GRANT-STATUS $GRANT-STATUS))
(PROJECT-FOR-PERIOD PERIOD))
(IF $PRINT-PROJECT-PERSON-SUMMARYS
THEN
(WRITE-PERSON-HISTORYS $PHS PERIOD))
(NEW-OUTPUT-PAGE)
(WRITE-ENTRYS 'CAPITAL-EQUIPMENT PERIOD)
(NEW-OUTPUT-PAGE)
(WRITE-ENTRYS 'TRAVEL PERIOD)
(NEW-OUTPUT-PAGE)
(WRITE-ENTRYS 'TOTAL-SPENT-THIS-MONTH PERIOD)
(NEW-OUTPUT-PAGE)
(WRITE-ENTRYS 'BALANCE-REMAINING PERIOD)
) ;end-defun
;project-for-period[p]
;projects a grant for a specified PERIOD P.
(DEFUN PROJECT-FOR-PERIOD (P)
(SETQ $GRANT-SUMMARYS NIL)
(LET START ← ∂PERIOD:START[P]
STOP ← ∂PERIOD:STOP[P]
DO
(DO
((MY START (NEXT-MY MY)))
((>MY MY STOP) NIL)
;Compute a projection for MY.
(LET PR ← (PROJECT $GRANT-STATUS MY)
DO
(IF $PRINT-PROJECT-MONTHLY
THEN
(NEW-OUTPUT-PAGE)
(WRITE-PROJECTION PR))
;Update $GRANT-STATUS according to the projection.
(SETQ $GRANT-STATUS (GRANT-STATUS PR)))))
(IF $PRINT-PROJECT-GRANT-SUMMARYS
THEN
(WRITE-GRANT-SUMMARYS))
) ;end-defun
;read-cmd[]
;reads a command from the first file on $EXE-FILES or takes from the TTY.
(DEFUN READ-CMD ()
(IF $EXE-FILES
THEN
(LET FILE ← (CAR $EXE-FILES)
THEN
CMD ← (READ FILE 'EOF)
DO
(IF (EQUAL 'EOF CMD)
THEN
(CLOSE FILE)
(SETQ $EXE-FILES (CDR $EXE-FILES))
(READ-CMD)
ELSE
CMD))
ELSE
(READ))
) ;end-defun
;read-file-name[default-ext]
;reads a file-name from the first file on $EXE-FILES or takes from the TTY.
;The default extension is DEFAULT-EXT.
;At top-level (TTY), one can type ↓xx.yy and so forth.
;Within a file, one must type (file ext dev (p pn)),
;as in (FOO EXE DSK (BUD BIS)).
(DEFUN READ-FILE-NAME (DEFAULT-EXT)
;Is input coming from a file?
(IF $EXE-FILES
THEN
(LET FILE ← (CAR $EXE-FILES)
THEN
FILE-NAME ← (READ FILE 'EOF)
DO
(IF (EQUAL 'EOF FILE-NAME)
THEN
(CLOSE FILE)
(SETQ $EXE-FILES (CDR $EXE-FILES))
(READ-FILE-NAME DEFAULT-EXT)
ELSE
FILE-NAME))
;From the TTY.
ELSE
(MAKE-GOOD-FILE-SPEC (NCONS (DEV-FILE-HAK TYI)) DEFAULT-EXT $USER-DIR))
) ;end-defun
;spaces[n]
;writes out N spaces. If N is 0 or less, it does nothing.
(DEFUN SPACES (N)
(DO
((I 1 (1+ I)))
((> I N) NIL)
(WRITE '| |))
) ;end-defun
;throw-bad-grant[grant,transaction,tag]
;checks whether GRANT is a valid grant.
;If not, then an error message is printed,
;mentioning TRANSACTION,
;and NIL is THROWN to TAG.
(DEFUN THROW-BAD-GRANT (GRANT TRANSACTION TAG)
(COND
((NOT (ATOM GRANT))
(BEEP)
(WRITELN '|Sorry, but `|
GRANT
'|' is not a valid grant name.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW TAG NIL))
((MEMQ GRANT $GRANT-NAMES))
(T
(BEEP)
(WRITELN '|Sorry, but `|
GRANT
'|' is not a grant known to us.|)
(WRITELN '|TRANSACTION=| TRANSACTION)))
) ;end-defun
;throw-bad-id[id,transaction,tag]
;checks whether ID is a valid ID.
;If not, then an error message is printed,
;mentioning TRANSACTION,
;and NIL is THROWN to TAG.
(DEFUN THROW-BAD-ID (ID TRANSACTION TAG)
(IF (NOT (VALID-ID ID))
THEN
(WRITELN '|Sorry, but `| ID '|' is not a valid ID.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW TAG NIL))
) ;end-defun
;throw-bad-monthly-rate[rate,transaction,tag]
;converts <N yearly> or <N monthly> to a number representing a monthly rate.
;If RATE does not have the correct form, then an error message is printed,
;mentioning TRANSACTION, and NIL is THROWN to TAG.
(DEFUN THROW-BAD-MONTHLY-RATE (RATE TRANSACTION TAG)
(IF (NOT (= 2 (LENGTH RATE)))
THEN
(WRITELN '|Sorry, but `| RATE '|' is not a proper RATE.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW TAG NIL))
(LET AMT ← (CAR RATE)
UNIT ← (CADR RATE)
DO
(IF (NOT (NUMBERP AMT))
THEN
(WRITELN '|Sorry, but `| AMT '|' is not a number.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW TAG NIL))
(SETQ AMT (FLOAT AMT))
(IF (OR (NOT (ATOM UNIT)) (NUMBERP UNIT))
THEN
(WRITELN '|Sorry, but `| UNIT '|' is not a valid UNIT.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW TAG NIL))
(SETQ AMT (CASEQ UNIT
(MONTHLY AMT)
(YEARLY (//$ AMT 12.0))
(T (WRITELN '|Sorry, but `| UNIT '|' is not a valid UNIT.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW TAG NIL))))
AMT)
) ;end-defun
;throw-bad-my[my,transaction,tag]
;checks whether MY is a valid MY.
;If not, then an error message is printed,
;mentioning TRANSACTION,
;and NIL is THROWN to TAG.
(DEFUN THROW-BAD-MY (MY TRANSACTION TAG)
(IF (NOT (VALID-MY MY))
THEN
(WRITELN '|Sorry, but `| MY '|' is not a valid MY.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW TAG NIL))
) ;end-defun
;throw-bad-percent[percent,transaction,tag]
;checks that PERCENT is a valid percent.
;If it's not, then a warnng message is printed,
;mentioning TRANSACTION.
(DEFUN THROW-BAD-PERCENT (PERCENT TRANSACTION TAG)
(COND
((NOT (NUMBERP PERCENT))
(WRITELN '|Sorry, but `| PERCENT '|' is not a valid PERCENT.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(BEEP)
(*THROW TAG NIL))
((OR (< (FLOAT PERCENT) 0.0)
(< 100.0 (FLOAT PERCENT)))
(WRITELN '|WARNING! `| PERCENT '|' is an unusual PERCENT.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(BEEP)))
(FLOAT PERCENT)
) ;end-defun
;throw-bad-period[p,transaction,tag]
;converts P into a valid period <possibly named>.
;If this can't be done,
;then an error message is printed mentioning TRANSACTION,
;and NIL is THROWN to TAG.
(MACRODEF THROW-BAD-PERIOD-ERROR ()
(WRITELN '|Sorry, but `| P '|' is not a valid PERIOD.|)
(WRITELN '|TRANSACTION=| TRANSACTION)
(*THROW TAG NIL)
) ;end-defun
(DEFUN THROW-BAD-PERIOD (P TRANSACTION TAG)
(COND
((ATOM P)
(IF (NUMBERP P) THEN (THROW-BAD-PERIOD-ERROR))
(IF (MEMQ P $PERIODS)
THEN (EVAL P)
ELSE (THROW-BAD-PERIOD-ERROR)))
((VALID-PERIOD P) P)
((VALID-MY P) (CREATE PERIOD START P STOP P))
(T (THROW-BAD-PERIOD-ERROR)))
) ;end-defun
;tuition-remission-rate[my]
;returns the tuition remission rate for the month MY.
;These rates come from the memo of Edward Cilley, dated 02 September 1980.
(DEFUN TUITION-REMISSION-RATE (MY)
(DECLARE (SPECIAL $OK))
(COND
((<=MY MY '(12 99)) 0.000)
((IN-PERIOD MY '((9 81) (8 82))) 0.255)
((IN-PERIOD MY '((9 82) (8 83))) 0.525)
((IN-PERIOD MY '((9 83) (8 84))) 0.819)
((IN-PERIOD MY '((9 84) (8 85))) 0.844)
(T (WRITELN '|ERROR: Tuition remission rate unavailable for month = | MY)
(SETQ $OK NIL)
0.0))
) ;end-defun
;valid-id[id]
;returns T if and only if ID is a non-numeric atom.
(DEFUN VALID-ID (ID)
(AND (ATOM ID)
(NOT (NUMBERP ID)))
) ;end-defun
;valid-my[my]
;returns T if and only if MY is a valid month-year.
(DEFUN VALID-MY (MY)
(AND
(NOT (NUMBERP MY))
(= 2 (LENGTH MY))
(LET MONTH ← ∂MY:MONTH[MY]
YEAR ← ∂MY:YEAR[MY]
DO
(AND
(FIXNUMP MONTH)
(FIXNUMP YEAR)
(< MONTH 13)
(> MONTH 0))))
) ;end-defun
;valid-period[p]
;returns T if and only P is a valid PERIOD.
(DEFUN VALID-PERIOD (P)
(AND
(= 2 (LENGTH P))
(LET START ← ∂PERIOD:START[P]
STOP ← ∂PERIOD:STOP[P]
DO
(AND (VALID-MY START)
(VALID-MY STOP)
(<=MY START STOP))))
) ;end-defun
;write-budget[b]
;writes out a BUDGET record in nice form.
(DEFUN WRITE-BUDGET (B)
(NEW-OUTPUT-PAGE)
(LET PERIOD ← ∂BUDGET:PERIOD[B]
THEN
START ← ∂PERIOD:START[PERIOD]
STOP ← ∂PERIOD:STOP[PERIOD]
DO
(WRITE '| BUDGET for the period |)(WRITE-MY START)
(WRITE '| thru |)(WRITE-MY STOP)(TERPRI)
(TERPRI)
(WRITE-TIME-STAMP)
(TERPRI)
; (TERPRI)
(WRITELN '|PROPOSAL TO: |)
; (TERPRI)
; (TERPRI)
(WRITELN '|TITLE: |)
; (TERPRI)
; (TERPRI)
(WRITELN '|SUBMITTED BY: |)
; (TERPRI)
; (TERPRI)
(WRITELN '|A. SALARIES AND WAGES|)
; (TERPRI)
; (TERPRI)
(WRITELN '| 1. Senior Personnel|)
; (TERPRI)
; (TERPRI)
(ITEMISE ∂BUDGET:SEN[B])
(TERPRI)
; (TERPRI)
(BUDGET-LINE '| 2. Student Research Assistants| ∂BUDGET:TSRA[B] 60)
; (TERPRI)
; (TERPRI)
(WRITELN '| 3. Support Personnel|)
; (TERPRI)
; (TERPRI)
(ITEMISE ∂BUDGET:SUP[B])
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '| Total Salaries & Wages| ∂BUDGET:TSW[B] 60)
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '|B. STAFF BENEFITS| ∂BUDGET:BEN[B] 60)
;If this BUDGET is for a single month, then print the benefit rate.
(IF (EQUAL START STOP)
THEN
(WRITELN '| (rate = | (BENEFITS START) '|)|))
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '|C. TOTAL SALARIES, WAGES AND STAFF BENEFITS| ∂BUDGET:TSWB[B] 60)
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '|D. CAPITAL EQUIPMENT| ∂BUDGET:TCAP[B] 60)
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '|E. EXPENDABLE SUPPLIES AND EQUIPMENT| ∂BUDGET:EXP[B] 60)
; (TERPRI)
; (TERPRI)
(WRITELN '|F. TRAVEL|)
; (TERPRI)
(BUDGET-LINE '| 1. Foreign| ∂BUDGET:FOR[B] 60)
; (TERPRI)
(BUDGET-LINE '| 2. Domestic| ∂BUDGET:DOM[B] 60)
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '|G. PUBLICATIONS| ∂BUDGET:PUB[B] 60)
; (TERPRI)
; (TERPRI)
(WRITELN '|H. OTHER COSTS|)
; (TERPRI)
(BUDGET-LINE '| 1. Communication (telephone)| ∂BUDGET:COMM[B] 60)
; (TERPRI)
(BUDGET-LINE '| 2. Computer cost| ∂BUDGET:COMP[B] 60)
; (TERPRI)
(BUDGET-LINE '| 3. Minor equipment and repair| ∂BUDGET:MER[B] 60)
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '|I. TOTAL COSTS (A thru H)| ∂BUDGET:TCBO[B] 60)
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '|J. INDIRECT COSTS (percentage of A thru H, less D)| ∂BUDGET:IND[B] 60)
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '| TUITION REMISSION| ∂BUDGET:REM[B] 60)
;If this BUDGET is for a single month,
;then print the tuition remission rate.
(IF (EQUAL START STOP)
THEN
(WRITELN '| (rate = | (TUITION-REMISSION-RATE START) '|)|))
; (TERPRI)
; (TERPRI)
(BUDGET-LINE '|K. TOTAL COSTS| ∂BUDGET:TC[B] 60))
) end-defun
;write-dollars-[x]
(DEFUN WRITE-DOLLARS- (X)
(LET N ← (FIX X)
THEN
+N ← (IF (< N 0) THEN (- N) ELSE N)
DO
(WRITE (N-CHARS-RJUST +N 6))
(IF (< N 0) THEN (WRITE '/-) ELSE (WRITE '/ )))
) ;end-defun
;write-entrys[type,period]
(DEFUN WRITE-ENTRYS (TYPE PERIOD)
(WRITELN '|Summary of |
TYPE
'| by month by grant.|)
(TERPRI)
;Sort the grant names.
(SETQ $GRANT-NAMES (SORT $GRANT-NAMES 'ALPHALESSP))
;Label the output columns.
(WRITE '|month |)
(FOR GRANT ε $GRANT-NAMES
DO
(WRITE (N-CHARS GRANT 6))
(SPACES 2))
(WRITE '|total|)
(TERPRI)
(WRITE '|----- |)
(FOR GRANT ε $GRANT-NAMES
DO
(WRITE '|------ |))
(WRITE '|-----|)
(TERPRI)
;Loop thru the months.
(DO
((MY ∂PERIOD:START[PERIOD] (NEXT-MY MY)))
((>MY MY ∂PERIOD:STOP[PERIOD]) NIL)
(WRITE-MY MY)
(LET TOTAL ← 0.0
AMT ← NIL
DO
;Loop thru the grants.
(FOR GRANT ε $GRANT-NAMES
DO
;Find the appropriate ENTRY, if any.
(FOR ENTRY ε $ENTRYS
DO
(IF (AND (EQUAL MY ∂ENTRY:MY[ENTRY])
(EQ GRANT ∂ENTRY:GRANT[ENTRY])
(EQ TYPE ∂ENTRY:TYPE[ENTRY]))
THEN
(SETQ AMT ∂ENTRY:AMT[ENTRY])))
(SPACES 1)
(IF AMT
THEN
(WRITE-DOLLARS- AMT)
(INCREMENT-BY TOTAL AMT)
ELSE
(WRITE '|xxxxxx |)))
(SPACES 1)
(WRITE-DOLLARS- TOTAL)
(TERPRI)))
) ;end-defun
;write-grant-status[gs]
;writes out a GRANT-STATUS record.
(DEFUN WRITE-GRANT-STATUS (GS)
(WRITE '|Grant status for | $TITLE '| at the end of |)
(WRITE-MY ∂GRANT-STATUS:MY[GS])
(TERPRI)
(TERPRI)
(WRITELN '| To Date Budgeted Remaining|)
(WRITELN '| ------- -------- ---------|)
(GS-LINE '|SALARIES AND WAGES|
∂GRANT-STATUS:TSW-TD[GS]
∂GRANT-STATUS:TSW-BUD[GS])
(TERPRI)
(GS-LINE '|STAFF BENEFITS|
∂GRANT-STATUS:BEN-TD[GS]
∂GRANT-STATUS:BEN-BUD[GS])
(TERPRI)
(GS-LINE '|CAPITAL EXPENDITURES|
∂GRANT-STATUS:CAP-TD[GS]
∂GRANT-STATUS:CAP-BUD[GS])
(TERPRI)
(GS-LINE '|TRAVEL|
∂GRANT-STATUS:TRA-TD[GS]
∂GRANT-STATUS:TRA-BUD[GS])
(TERPRI)
(GS-LINE '|EXPENDABLE MATERIALS|
∂GRANT-STATUS:EXP-TD[GS]
∂GRANT-STATUS:EXP-BUD[GS])
(TERPRI)
(GS-LINE '|INDIRECT COSTS|
∂GRANT-STATUS:IND-TD[GS]
∂GRANT-STATUS:IND-BUD[GS])
(TERPRI)
(LET TD ← 0.0 BUD ← 0.0
DO
(INCREMENT-BY TD ∂GRANT-STATUS:TSW-TD[GS])
(INCREMENT-BY BUD ∂GRANT-STATUS:TSW-BUD[GS])
(INCREMENT-BY TD ∂GRANT-STATUS:BEN-TD[GS])
(INCREMENT-BY BUD ∂GRANT-STATUS:BEN-BUD[GS])
(INCREMENT-BY TD ∂GRANT-STATUS:CAP-TD[GS])
(INCREMENT-BY BUD ∂GRANT-STATUS:CAP-BUD[GS])
(INCREMENT-BY TD ∂GRANT-STATUS:TRA-TD[GS])
(INCREMENT-BY BUD ∂GRANT-STATUS:TRA-BUD[GS])
(INCREMENT-BY TD ∂GRANT-STATUS:EXP-TD[GS])
(INCREMENT-BY BUD ∂GRANT-STATUS:EXP-BUD[GS])
(INCREMENT-BY TD ∂GRANT-STATUS:IND-TD[GS])
(INCREMENT-BY BUD ∂GRANT-STATUS:IND-BUD[GS])
(GS-LINE '|TOTAL| TD BUD))
) ;end-defun
;write-grant-summarys[]
(DEFUN WRITE-GRANT-SUMMARYS ()
;Label the output.
(NEW-OUTPUT-PAGE)
(WRITELN '|Summary of |
$TITLE
'| by month by expenditure type.|)
(TERPRI)
(WRITELN '| salary total|)
(WRITELN '| wages capital expendable indirect this balance|)
(WRITELN '|month benefits equip travel materials costs month remaining|)
(WRITELN '|----- -------- ------- ------ ---------- -------- ----- ---------|)
(TERPRI)
;Loop thru the records in $GRANT-SUMMARYS.
(FOR GS ε $GRANT-SUMMARYS
DO
(WRITE-MY ∂GRANT-SUMMARY:MY[GS])
(SPACES 3) (WRITE-DOLLARS- ∂GRANT-SUMMARY:SWB[GS])
(SPACES 3) (WRITE-DOLLARS- ∂GRANT-SUMMARY:CAP[GS])
(SPACES 3) (WRITE-DOLLARS- ∂GRANT-SUMMARY:TRA[GS])
(SPACES 3) (WRITE-DOLLARS- ∂GRANT-SUMMARY:EXP[GS])
(SPACES 3) (WRITE-DOLLARS- ∂GRANT-SUMMARY:IND[GS])
(SPACES 3) (WRITE-DOLLARS- ∂GRANT-SUMMARY:TOT[GS])
(SPACES 3) (WRITE-DOLLARS- ∂GRANT-SUMMARY:REM[GS])
(TERPRI))
) ;end-defun
;write-money[x]
;writes out a character string for the FLOATNUM x.
;Output is always 11 characters:
; a sign, with `+' omitted;
; the dollars, 7 characters;
; the decimal point;
; 2 characters worth of cents.
;Budgets greater than $9,999,999.999 will fuck up.
(DEFUN WRITE-MONEY (X)
(LET SIGN ← '| |
DO
;Make X into a positive number and update SIGN.
(IF (> 0.0 X)
THEN
(SETQ SIGN '-)
(SETQ X (-$ X)))
;Figure out the character representation of X.
(LET DOLLARS ← (DOLLARS X)
CENTS ← (CENTS X)
DO
(WRITE SIGN)
(SPACES (- 7 (LENGTH DOLLARS)))
(MAPC 'WRITE DOLLARS)
(WRITE '|.|)
(MAPC 'WRITE CENTS)
NIL))
) ;end-defun
;write-money-[x]
;writes out X as dollars and cents,
;followed by either a ` ' or `-'.
(DEFUN WRITE-MONEY- (X)
(LET POS ← (-$ X)
DO
(IF (< X 0.0)
THEN
(WRITE-MONEY POS)
(WRITE '|-|)
ELSE
(WRITE-MONEY X)
(WRITE '| |)))
) ;end-defun
;write-my[my]
;writes out the month-year MY as month/year.
(DEFUN WRITE-MY (MY)
(LET MONTH ← ∂MY:MONTH[MY]
YEAR ← ∂MY:YEAR[MY]
DO
(IF (< MONTH 10) THEN (WRITE '|0|))
(WRITE MONTH)
(WRITE '//)
(WRITE YEAR))
) ;end-defun
;write-page-mark[]
;writes a page mark, obviously.
(DEFUN WRITE-PAGE-MARK ()
(TYO `14)
) ;end-defun
;write-percent-[percent]
;writes out a percent as ` 50 ' or ` 50-' or `100-'
(DEFUN WRITE-PERCENT- (PERCENT)
(LET SIGN ← (IF (< PERCENT 0.0) THEN '- ELSE '| |)
PERCENT ← (IF (< PERCENT 0.0) THEN (-$ PERCENT) ELSE PERCENT)
DO
(WRITE (N-CHARS-RJUST (FIX PERCENT) 3))
(WRITE SIGN))
) ;end-defun
;write-person-historys[phs,p]
;writes out charts of the form:
;
; Summary of BINFORD on all grants from 10/80 thru 02/81
;
; month salary ARPA NSF78 total
; ----- ------ ------ ------ -----
; 10/80 xxxx.xx 50 50 100
;
;PHS is a list of PERSON-HISTORY records.
;P is the period involved.
(DEFUN WRITE-PERSON-HISTORYS (PHS P)
(LET START ← ∂PERIOD:START[P]
STOP ← ∂PERIOD:STOP[P]
IDS ← NIL
GRANTS ← NIL
SALARY ← 0.0
PERCENT ← 0.0
TOTAL-PERCENT ← 0.0
MEANWHILE
;Create a list of the IDs (people) involved.
(FOR PH ε PHS DO
(LET ID ← ∂PERSON-HISTORY:ID[PH]
DO
(IF (NOT (MEMQ ID IDS))
THEN
(ADD-AT-END IDS ID))))
THEN
;Sort the IDs.
IDS ← (SORT IDS 'ALPHALESSP)
DO
;Loop thru the IDs.
(FOR ID ε IDS DO
;Label this output page.
(NEW-OUTPUT-PAGE)
(WRITE '|Summary of | ID '| on all grants from |)
(WRITE-MY START)
(WRITE '| thru |)
(WRITE-MY STOP)
(TERPRI)
(TERPRI)
;Create a list of GRANTS involved for this person.
(SETQ GRANTS NIL)
(FOR PH ε PHS
DO
(IF (AND (EQ ID ∂PERSON-HISTORY:ID[PH])
(NOT (MEMQ ∂PERSON-HISTORY:GRANT[PH] GRANTS)))
THEN
(ADD-AT-END GRANTS ∂PERSON-HISTORY:GRANT[PH])))
;Label the columns of the output.
(SPACES 22)
(FOR GRANT ε GRANTS
DO
(WRITE '/%)
(SPACES 8))
(SPACES 1)
(WRITE '/%)
(TERPRI)
(WRITE '|month salary |)
(FOR GRANT ε GRANTS
DO
(WRITE (N-CHARS GRANT 6))
(SPACES 3))
(WRITE '|total|)
(TERPRI)
(WRITE '|----- ------ |)
(FOR GRANT ε GRANTS
DO
(WRITE '|------ |))
(WRITE '|-----|)
(TERPRI)
;Loop thru the MYs.
(DO ((MY START (NEXT-MY MY)))
((>MY MY STOP) NIL)
;Write out invariant information.
(SETQ SALARY (GET-MONTHLY-SALARY ID MY))
(WRITE-MY MY)
(WRITE-MONEY SALARY)
(SPACES 5)
;Loop thru the GRANTs for this person.
(SETQ TOTAL-PERCENT 0.0)
(FOR GRANT ε GRANTS
DO
;Loop thru the PERSON-HISTORYs.
(SETQ PERCENT 0.0)
(FOR PH ε PHS DO
(IF (AND (EQ ID ∂PERSON-HISTORY:ID[PH])
(EQ GRANT ∂PERSON-HISTORY:GRANT[PH])
(EQUAL MY ∂PERSON-HISTORY:MY[PH]))
THEN
(SETQ PERCENT (+$ PERCENT ∂PERSON-HISTORY:PERCENT[PH]))))
(WRITE-PERCENT- PERCENT)
(SPACES 5)
(SETQ TOTAL-PERCENT (+$ PERCENT TOTAL-PERCENT)))
(SPACES 1)
(WRITE-PERCENT- TOTAL-PERCENT)
(TERPRI))))
) ;end-defun
;write-projection[pr]
;writes out the PROJECTION PR in pretty format.
(DEFUN WRITE-PROJECTION (PR)
;Write some labels at the top of the page.
(LET MY ← ∂PROJECTION:MY[PR]
DO
(WRITE '|Projection for | $TITLE '| for the month |)
(WRITE-MY MY)(TERPRI))
(TERPRI)
(WRITE-TIME-STAMP)
(TERPRI)
(WRITELN '| This Month To Date Budgeted Remaining|)
(WRITELN '| ---------- ------- -------- ---------|)
;Salaries and Wages.
(TERPRI)
(WRITELN '|SALARIES AND WAGES|)
(FOR ITEM ε ∂PROJECTION:SW[PR]
DO
(ACT-SW-LINE ∂SW-LINE:ID[ITEM]
∂SW-LINE:PERCENT[ITEM]
∂SW-LINE:MONTHLY[ITEM]
∂SW-LINE:THIS-MONTH[ITEM]
∂SW-LINE:COMMENT[ITEM]))
(WRITELN '| ----------|)
(PRO-LINE '|TOTAL SALARIES AND WAGES|
∂PROJECTION:SW-TOT:TM[PR]
∂PROJECTION:SW-TOT:TD[PR]
∂PROJECTION:SW-TOT:BUD[PR])
;Staff Benefits.
(TERPRI)
(TERPRI)
(PRO-LINE (CATEN '|STAFF BENEFITS at | ∂PROJECTION:BEN-RATE[PR])
∂PROJECTION:BEN-TOT:TM[PR]
∂PROJECTION:BEN-TOT:TD[PR]
∂PROJECTION:BEN-TOT:BUD[PR])
;Tuition Remission.
(TERPRI)
(TERPRI)
(PRO-LINE (CATEN '|TUITION REMISSION at | ∂PROJECTION:REM-RATE[PR])
∂PROJECTION:REM-TOT:TM[PR]
∂PROJECTION:REM-TOT:TD[PR]
∂PROJECTION:REM-TOT:BUD[PR])
;Capital Expenditures.
(TERPRI)
(TERPRI)
(WRITELN '|CAPITAL EXPENDITURES|)
(FOR CAP ε ∂PROJECTION:CAP[PR]
DO
(SPACES 2)
(WRITE (N-CHARS ∂ID-AMT:ID[CAP] 30))
(WRITE-MONEY- ∂ID-AMT:AMT[CAP])
(TERPRI))
(WRITELN '| ----------|)
(PRO-LINE '|TOTAL FOR CAPITAL EXPENDITURES|
∂PROJECTION:CAP-TOT:TM[PR]
∂PROJECTION:CAP-TOT:TD[PR]
∂PROJECTION:CAP-TOT:BUD[PR])
;Travel.
(TERPRI)
(TERPRI)
(WRITELN '|TRAVEL|)
(FOR X ε ∂PROJECTION:TRA[PR]
DO
(SPACES 2)
(WRITE (N-CHARS ∂ID-AMT:ID[X] 30))
(WRITE-MONEY- ∂ID-AMT:AMT[X])
(TERPRI))
(WRITELN '| ----------|)
(PRO-LINE '|TOTAL FOR TRAVEL|
∂PROJECTION:TRA-TOT:TM[PR]
∂PROJECTION:TRA-TOT:TD[PR]
∂PROJECTION:TRA-TOT:BUD[PR])
;Expendable Materials.
(TERPRI)
(TERPRI)
(WRITELN '|EXPENDABLE MATERIALS|)
(FOR X ε ∂PROJECTION:EXP[PR]
DO
(SPACES 2)
(WRITE (N-CHARS ∂ID-AMT:ID[X] 30))
(WRITE-MONEY- ∂ID-AMT:AMT[X])
(TERPRI))
(WRITELN '| ----------|)
(PRO-LINE '|TOTAL FOR EXPENDABLE MATERIALS|
∂PROJECTION:EXP-TOT:TM[PR]
∂PROJECTION:EXP-TOT:TD[PR]
∂PROJECTION:EXP-TOT:BUD[PR])
;Indirect Costs.
(TERPRI)
(TERPRI)
(PRO-LINE (CATEN '|INDIRECT COSTS at | ∂PROJECTION:IND-RATE[PR])
∂PROJECTION:IND:TM[PR]
∂PROJECTION:IND:TD[PR]
∂PROJECTION:IND:BUD[PR])
;Total.
(TERPRI)
(WRITELN '| ---------- --------- --------- ---------|)
(PRO-LINE '|TOTAL COSTS|
∂PROJECTION:TOT:TM[PR]
∂PROJECTION:TOT:TD[PR]
∂PROJECTION:TOT:BUD[PR])
) ;end-defun
;write-source-files[]
;writes an output page naming source files READ or EXEd.
(DEFUN WRITE-SOURCE-FILES ()
(WRITELN '|Source files for this output.|)
(TERPRI)
(WRITE '|Done with BUDGET|)
(WRITE-WHEN (DUMP-DATE-TIME))
(WRITE '| by |)
(WRITELN $UNAME)
(TERPRI)
(WRITELN '|cmd file|)
(WRITELN '|--- ----|)
(FOR PAIR ε $SOURCE-FILES
DO
(LET CMD ← (CAR PAIR)
FILE ← (CDR PAIR)
DO
(WRITE (N-CHARS CMD 4))
(SPACES 3)
(WRITE-A-FILE-SPEC FILE)
(TERPRI)))
) ;end-defun
;write-time-stamp[]
(DEFUN WRITE-TIME-STAMP ()
(WRITE '|Prepared by |)
(WRITE $UNAME)
(WRITE '| using BUDGET|)
(WRITE-WHEN (DUMP-DATE-TIME))
(TERPRI)
) ;end-defun